home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / sys / zeval.t < prev    next >
Text File  |  1988-02-05  |  6KB  |  141 lines
  1. (herald zeval
  2.         (env tsys (osys kernel) (osys list)))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. ;;; Evaluator
  28.  
  29. ;++ Should the Z system handle syntax?
  30.  
  31. (define (z-eval exp env)
  32.   (cond ((atom? exp)
  33.          (cond ((symbol? exp) (z-evalue exp env))
  34.                (else exp)))
  35.         (else
  36.          (let ((head (car exp)))
  37.            (cond ((pair? head)
  38.                   (z-eval-call (z-eval head env) (cdr exp) env))
  39.                  ((symbol? head)
  40.                   (z-eval-symbol-form head exp env))
  41.                  ((and (syntax-present?) (syntax-descriptor? head))
  42.                   (z-eval-special-form head exp env))
  43.                  (else
  44.                   (z-eval-call (z-eval head env) (cdr exp) env)))))))
  45.  
  46. (define (z-eval-symbol-form head exp env)
  47.   (case head
  48.         ((quote) (cadr exp))
  49.         ((if)
  50.          (if (z-eval (cadr exp) env)
  51.              (z-eval (caddr exp) env)
  52.              (z-eval (cadddr exp) env)))
  53.         ((block)
  54.          (z-eval-rest (cdr exp) env))
  55.         ((lambda)
  56.          (z-eval-lambda (cdr exp) env))
  57.         ((named-lambda)
  58.          (z-eval-lambda (cddr exp) env))
  59.         ((set-variable-value)
  60.          (cond ((atom? (cadr exp))
  61.                 (z-set-evalue (cadr exp) env (z-eval (caddr exp) env) nil nil))
  62.                (else
  63.                 (z-eval `((setter ,(caadr exp)) ,@(cdadr exp),@(cddr exp)) env))))
  64.         ((define-variable-value)
  65.          (z-set-evalue (cadr exp) env (z-eval (caddr exp) env) t t))
  66.         (else                                       
  67.          (cond ((and (syntax-present?)
  68.                      (syntax-table-entry standard-syntax-table head))
  69.                 => (lambda (descr)
  70.                      (z-eval-special-form descr exp env)))
  71.                (else
  72.                 (z-eval-call (z-evalue head env) (cdr exp) env))))))
  73.  
  74. (define (z-eval-special-form descr exp env)
  75.   (let ((new-exp (check-special-form-syntax descr exp)))
  76.     (cond ((neq? exp new-exp)
  77.            ;; An error was reported, and luser gave us a new form.
  78.            (z-eval new-exp env))
  79.           (else
  80.            ;; Non-primitive syntax; assume it's a macro.
  81.            (z-eval (expand-macro-form descr exp standard-syntax-table) env)))))
  82.  
  83. (define (z-eval-call proc args env)
  84.   (cond ((null-list? args)
  85.          (proc))
  86.         (else
  87.          (let ((arglist (cons (z-eval (car args) env) '())))
  88.            (do ((z arglist (cdr z))
  89.                 (args (cdr args) (cdr args)))
  90.                ((null-list? args)
  91.                 (apply proc arglist))
  92.              (set (cdr z) (cons (z-eval (car args) env) '())))))))
  93.  
  94.  
  95. (define (z-eval-lambda params+body env)
  96.   (let ((params (car params+body))
  97.         (body (cdr params+body)))
  98.     (cond ((null? params)               ; trivial pessimization
  99.                (lambda ()
  100.                  (z-eval-rest body env)))
  101.               (else
  102.                (lambda args
  103.                  (z-eval-rest body
  104.                          (cons env (cons params args))))))))
  105.  
  106. (define (z-eval-rest exps env)
  107.   (cond ((atom? (cdr exps)) (z-eval (car exps) env))
  108.         (else (z-eval (car exps) env)
  109.                   (z-eval-rest (cdr exps) env))))
  110.  
  111. (define (z-evalue id env)
  112.   (cond ((not (pair? env))
  113.          (let ((probe (env id nil nil)))
  114.            (cond (probe (vcell-contents probe))
  115.                  (else (error "~s is unbound" id)))))
  116.         (else (iterate loop ((ids (cadr env)) (vals (cddr env)))
  117.                         (cond ((atom? ids)
  118.                                (cond ((eq? id ids) vals)
  119.                                          (else (z-evalue id (car env)))))
  120.                               ((eq? id (car ids))
  121.                                (car vals))
  122.                               (else     
  123.                                (loop (cdr ids) (cdr vals))))))))
  124.  
  125. (define (z-set-evalue id env val local? def?)
  126. ;++ why not LOCALE? or ENVIRONMENT?
  127.   (cond ((not (pair? env))
  128.          (*set-value env id val)
  129.          (no-value))
  130.         (else
  131.          (iterate loop ((ids (cadr env)) (vals (cddr env)))
  132.            (cond ((atom? ids)
  133.                   (cond ((eq? id ids)
  134.                          (error "~s: can't set value of a rest-arg!" id))
  135.                         (else (z-set-evalue id (car env) val local? def?))))
  136.                  ((eq? id (car ids))
  137.                   (set (car vals) val)
  138.                   val)
  139.                  (else
  140.                   (loop (cdr ids) (cdr vals))))))))
  141.